perm filename GENPAT[PAT,LMM]1 blob
sn#058037 filedate 1973-08-13 generic text, type T, neo UTF8
(FILECREATED "13-AUG-73 22:51:20" GENPAT)
(DEFINEQ
(COLLECT
[LAMBDA (FILE)
(/SET (QUOTE CURRENTFILE)
FILE)
(AND FILE
(PROGN (AND (NOT (FMEMB FILE FILELST))
(/SET (QUOTE FILELST)
(CONS FILE FILELST)))
[OR (EQ (CAAAR (SETQ FILE (FILEVARS FILE)))
(QUOTE FNS))
(/SET FILE (CONS (LIST (QUOTE FNS))
(COND
[(EQ (CAR FILE)
(QUOTE NOBIND))
(LIST (LIST (QUOTE VARS]
(T (CAR FILE]
CURRENTFILE])
(LISTFILE
[LAMBDA (FIL LISTFILEHOST LISTFILELOGIN)
(BKSYSBUF (CONCAT "FTP
" [SETQ LISTFILEHOST (OR LISTFILEHOST HOST (SETQ HOST
(PROGN (PRIN1 "HOST? ")
(READ T]
"
LOG "
[OR LISTFILELOGIN (GETP LISTFILEHOST
(QUOTE LOGIN))
(PUT LISTFILEHOST (QUOTE LOGIN)
(PROGN (PRIN1 LISTFILEHOST T)
(PRIN1 " LOGIN? " T)
(READ T]
"
TE
SE " FIL "
≠DIS
QUI
QUI
"))
(KFORK (SUBSYS])
(SAVE
[LAMBDA NIL
(AND (NLISTP (SYSOUT (QUOTE LARRY.SYS)))
(DELFILE (QUOTE LARRY.SYS])
(CGQ
[NLAMBDA (FN)
(COPY (GETD FN])
(LISTFILES
[LAMBDA (FILLST)
[COND
((NULL FILLST)
(SETQ FILLST NOTLISTEDFILES))
((NLISTP FILLST)
(SETQ FILLST (CONS FILLST]
(PROG1 (for FIL in FILLST do (LISTFILE (OR (INFILEP FIL)
(ERROR
"NO SUCH FILE TO LIST" FIL)
))
(/DSUBST NIL FIL NOTLISTEDFILES))
(SETQ NOTLISTEDFILES (/DREMOVE NIL NOTLISTEDFILES])
(PICK
[LAMBDA (L)
(CAR (NTH L (RAND1 (LENGTH L])
(RAND1
[LAMBDA (N)
(XLATE (RAND 0.0 .999999)
N])
(ORR
[NLAMBDA X
(PROG (TEM)
[COND
((NULL STACK)
(RETURN (EVAL (PICK X]
(SETQ X (NTH X (OR (CAR STACK)
0)))
(COND
((EVERY (CDR STACK)
(QUOTE NULL))
(GO BUMP)))
LP (COND
((NULL X)
(RPLACA STACK NIL)
(ERROR!)))
[COND
((SETQ TEM (ERSET (CAR X)))
(RETURN (CAR TEM]
BUMP(SETQ X (CDR X))
(RPLACA STACK (ADD1 (OR (CAR STACK)
0)))
(GO LP])
(PAT
[LAMBDA NIL
(LISTOF (PATELT)
1])
(PATELT
[LAMBDA NIL
(ORR (ORR (QUOTE &)
(NUMBER)
(STRING)
NIL
(CONS (QUOTE =)
(EXPRESSION))
(CONS (QUOTE ==)
(EXPRESSION))
(CONS (QUOTE ')
(EXPRESSION)))
(ORR (QUOTE $)
(QUOTE --))
(CONS (QUOTE @)
(CONS (FNNAME)
(PATELT)))
(CONS (ORR (QUOTE *EVERY*)
(QUOTE *ANY*))
(PAT))
(ORR (CONS (ORR (QUOTE <-)
(QUOTE ←))
(CONS (VAR)
(PATELT)))
(CONS (ORR (QUOTE →)
(QUOTE ->))
(CONS (EXPRESSION)
(PATELT)))
(CONS (QUOTE *)
(PATELT)))
(CONS (QUOTE SUBPAT)
(PAT))
(CONS (QUOTE })
(PATELT))
(CONS (QUOTE !)
(PATELT))
(CONS (QUOTE $PACKED$)
(ORR (NUMBER)
(NUMBEREXPRESSION])
(EXPRESSION
[LAMBDA (FLG)
(ORR (COND
(FLG NIL)
(T (VAR)))
(VAR)
(NUMBER)
(CONS (SETQ FLG (FNNAME))
(COND
((SUBRP FLG)
(LIST (EXPRESSION)))
((GETD FLG)
(FOR X FROM 1 UNTIL (NARGS FLG) COLLECT (EXPRESSION))
)
(T (LISTOF (EXPRESSION)
0 3])
(VAR
[LAMBDA NIL
(PACK (LIST (PREFIX)
(VOWEL)
(SUFFIX])
(GENPAT
[LAMBDA (STARDONE)
(PROG (VAL)
(PRINTDEF (SETQ VAL (PAT)))
(TERPRI)
(RETURN VAL])
(XLATE
[LAMBDA (N1 N2)
(ADD1 (FTIMES N2 (EXPT (FDIFFERENCE N1 .999999)
2])
(LISTOF
[NLAMBDA (EXPR MIN MAX)
(PROG (VAL (MIN (OR (EVAL MIN)
0))
(MAX (OR (EVAL MAX)
4)))
(RPTQ (IPLUS MIN (RAND1 (IDIFFERENCE MAX MIN)))
(SETQ VAL (CONS (EVAL EXPR)
VAL)))
(RETURN VAL])
(NUMBER
[LAMBDA NIL
(RAND 2 10])
(FNNAME
[LAMBDA NIL
(PICK (QUOTE (NUMBERP GETD EXPRP ATOM LITATOM STRINGP NNIL ZEROP
INFILEP LISTP NLISTP MINUSP SMALLP
EASYTORECOMPUTE])
(UNPATPARSE
[LAMBDA (PAT) (* Unpatparse each
pattern element and
NCONC values together)
(MAPCONC PAT (FUNCTION UNPATPARSELT])
(UNPATPARSELT
[LAMBDA (PATELT) (* create valid input
sytax)
(PROG (TEM)
(COND
((LITATOM PATELT)
(SELECTQ PATELT
((& $ * -- NIL T)
(LIST PATELT))
(HELP (QUOTE "CAN'T UNPATPARSE")
PATELT)))
((LISTP PATELT)
(SELECTQ (CAR PATELT)
((= == ')
(PACKRAT (CAR PATELT)
(CDR PATELT)))
[* (COND
((EQ (CDR PATELT)
(QUOTE &))
(LIST (QUOTE *)))
(T (CONS (QUOTE *←)
(UNPATPARSELT (CDR PAT]
[$PACKED$ (COND
((NLISTP (CDR PATELT))
(PACKRAT (QUOTE $)
(CDR PATELT)))
(T (HELP "UNPARSE: $PACKED$ LISTP"
PATELT]
[≠ (LIST (PACK (CDR PATELT]
[≠≠ (LIST (PACKC (APPEND (CDDDR PATELT)
(QUOTE (27 27]
[SUBPAT (LIST (UNPATPARSE (CDR PATELT]
[@ (PACKRAT2 (APPEND (UNPATPARSELT (CDDR PATELT))
(COND
((NLISTP (CADR PATELT))
(LIST (QUOTE @)
(CADR PATELT)))
((EQ (CAADR PATELT)
(QUOTE }))
(LIST (QUOTE }@)
(CDADR PATELT)))
(T (HELP "UNPARSE"]
[(*ANY* *EVERY*)
(LIST (CONS (CAR PATELT)
(UNPATPARSE (CDR PATELT]
((← <-)
(NCONC [PACKRAT (CADR PATELT)
(QUOTE ←)
(CAR (SETQ TEM
(UNPATPARSELT
(CDDR PATELT]
(CDR TEM)))
[(-> →)
(PACKRAT2 (APPEND (UNPATPARSELT (CDDR PATELT))
(LIST (QUOTE ←)
(CADR PATELT]
((} !)
(NCONC [PACKRAT (QUOTE !)
(CAR (SETQ TEM
(UNPATPARSELT
(CDR PATELT]
(CDR TEM)))
(HELP "UNPARSE")))
((OR (STRINGP PATELT)
(NUMBERP PATELT))
(LIST PATELT))
(T (HELP "UNPARSE"])
(PACKRAT
[LAMBDA N
(PROG ((CNT N)
VAL ATLST)
LP (COND
((ZEROP CNT)
(RETURN (PACKRAT1 ATLST VAL)))
((LITATOM (ARG N CNT))
(SETQ ATLST (CONS (ARG N CNT)
ATLST)))
(T (SETQ VAL (CONS (ARG N CNT)
(PACKRAT1 ATLST VAL)))
(SETQ ATLST NIL)))
(SETQ CNT (SUB1 CNT))
(GO LP])
(PACKRAT1
[LAMBDA (ATLST LST)
(COND
(ATLST (CONS (PACK ATLST)
LST))
(T LST])
(TSTMATCH
[LAMBDA (EXPR FAULTFN) (* EXPR AND FAULTFN ARE
NEEDED BY CLISPLOOKUP)
(USEREXEC
(PACK (LIST VARTOMATCH (QUOTE ":")))
(APPEND
[QUOTE ([G (CAR (LISPXUNREAD (LIST (UNPATPARSE (PROG (STARDONE)
(PAT]
(STOP (RETFROM (QUOTE USEREXEC)))
(GP (CAR (LISPXUNREAD (LIST (PROG (STARDONE)
(PAT']
LISPXMACROS)
(QUOTE LMUSERFN])
(LMUSERFN
[LAMBDA (PAT EXPR)
(COND
((LISTP PAT)
(OUTPUT T)
(LISPXPRINTDEF (PROGN (SETQ EXPR (MAKEMATCH VARTOMATCH PAT))
(COND
(CLMATCHFLG (CLISPIFY EXPR))
(T EXPR)))
1 T)
(LISPXTERPRI T)
(COND
((OPENP EXAMPLEFILE (QUOTE OUTPUT))
(OUTPUT EXAMPLEFILE)
(PRINT PAT)
(TERPRI)
(PRINTDEF EXPR)
(PRIN1 "
")))
(OUTPUT T)
(RPLACA LISPXHIST (QUOTE !))
(RETFROM (QUOTE LISPX))
T])
(PREFIX
[LAMBDA NIL
(PICK0 (QUOTE ("" B C D F G H J K L M N P Q R S T V W X Z])
(SUFFIX
[LAMBDA NIL
(PICK0 (QUOTE (B C D E F G H J K L M N P Q R S T V W X Z])
(VOWEL
[LAMBDA NIL
(PICK0 (QUOTE (A E I O U OU])
(PICK0
[LAMBDA (L)
(CAR (NTH L (RAND 1 (LENGTH L])
(PARSEUSERFN
[LAMBDA (PAT EXPR)
(COND
((LISTP PAT)
(PRIN1 "Parses to:" T)
(PRINT (SETQ EXPR (PATPARSE (COPY PAT)))
T)
(PRIN1 "Which unparses to:" T)
(PRINT (SETQ EXPR2 (UNPATPARSE EXPR))
T)
(TERPRI T)
(CPLISTS PAT EXPR2)
(TERPRI T)
(CPLISTS EXPR (PATPARSE EXPR2))
(RPLACA LISPXHIST EXPR)
(RETFROM (QUOTE LISPX))
T])
(TSTPARSE
[LAMBDA NIL
(USEREXEC
(QUOTE PAT?)
(APPEND
[QUOTE ([G (CAR (LISPXUNREAD (LIST (UNPATPARSE (PROG (STARDONE)
(PAT]
(STOP (RETFROM (QUOTE USEREXEC)))
(GP (CAR (LISPXUNREAD (LIST (PROG (STARDONE)
(PAT']
LISPXMACROS)
(QUOTE PARSEUSERFN])
(ORR1
[NLAMBDA L
(EVAL (PICK0 L])
(PACKRAT2
[LAMBDA (L)
(APPLY (QUOTE PACKRAT)
L])
(STRING
[LAMBDA NIL
(MKSTRING (VAR])
(NUMBEREXPRESSION
[LAMBDA NIL
(ORR (VAR)
(LIST (QUOTE IPLUS)
(VAR)
(VAR])
(ERSET
[LAMBDA (X)
(PROG ((STACK (CDR STACK)))
(ERRORSET X])
)
(LISPXPRINT (QUOTE GENPATFNS)
T)
(RPAQQ GENPATFNS
(COLLECT LISTFILE SAVE CGQ LISTFILES PICK RAND1 ORR PAT PATELT
EXPRESSION VAR GENPAT XLATE LISTOF NUMBER FNNAME
UNPATPARSE UNPATPARSELT PACKRAT PACKRAT1 TSTMATCH
LMUSERFN PREFIX SUFFIX VOWEL PICK0 PARSEUSERFN
TSTPARSE ORR1 PACKRAT2 STRING NUMBEREXPRESSION ERSET))
(LISPXPRINT (QUOTE GENPATVARS)
T)
(RPAQQ GENPATVARS ((FNS DE PAT' PATELT' ELTPATELT' STUPID SMART)
FUNNYATOMLST VARTOMATCH (VARS (CURRENTFILE)
(HOST)
(EXAMPLEFILE (QUOTE EXAMPLES))
CLMATCHFLG PATTERNS)
(ADVISE DEFINE LOAD UNBREAK0)
[P (RELINK (QUOTE (UNBREAK]
(P (MOVD (QUOTE LISPXPRINT)
(QUOTE LISPXPRINTDEF)))
(PROP MACRO ORR LISTOF)
(ADVICE PATELT)))
(DEFINEQ
(DE
[NLAMBDA L
(DEFINE (LIST L])
(PAT'
[LAMBDA NIL
(FOR X FROM 1 TO (RAND 1 5) JOIN (PATELT'])
(PATELT'
[LAMBDA NIL
(ORR1 (ELTPATELT')
(LIST (ORR1 (QUOTE $)
(QUOTE $$)
(QUOTE --)))
(ORR1 [PACKRAT2 (CONS (VAR)
(CONS (QUOTE ←)
(PATELT']
[PACKRAT2 (APPEND (PATELT')
(LIST (QUOTE ←)
(EXPRESSION]
[PACKRAT2 (CONS (QUOTE !)
(CONS (VAR)
(CONS (QUOTE ←)
(PATELT']
[PACKRAT2 (APPEND (PATELT')
(LIST (ORR (QUOTE @)
(QUOTE }@))
(FNNAME]
(PACKRAT (QUOTE $)
(ORR (NUMBER)
(VAR)))
(PACKRAT (QUOTE !←)
(EXPRESSION])
(ELTPATELT'
[LAMBDA NIL
(ORR1 [LIST (CONS (ORR (QUOTE *ANY*)
(QUOTE *EVERY*))
(JOIN (ELTPATELT') FROM 1 TO (RAND 2 5]
(PACKRAT (ORR (QUOTE =)
(QUOTE ==))
(EXPRESSION))
(PACKRAT (QUOTE ')
(EXPRESSION))
(LIST (ORR1 (QUOTE &)
(QUOTE $1)))
(LIST (QUOTE *))
(PACKRAT (VAR)
(ORR (QUOTE ≠)
(QUOTE ≠≠)))
(LIST (PAT'))
(LIST (ORR1 (VAR)
(NUMBER)
T NIL "STRING"))
[PACKRAT2 (APPEND (ELTPATELT')
(LIST (ORR (QUOTE @)
(QUOTE }@))
(FNNAME]
(PACKRAT2 (CONS (QUOTE })
(ELTPATELT')))
[PACKRAT2 (APPEND (ELTPATELT')
(LIST (QUOTE ←)
(EXPRESSION]
(PACKRAT2 (CONS (VAR)
(CONS (QUOTE ←)
(ELTPATELT'])
(STUPID
[LAMBDA NIL
(LIST [ADVISE (QUOTE 'NOT)
(QUOTE (RETURN (LIST (QUOTE NOT)
X]
[ADVISE (QUOTE 'NLEFT)
(QUOTE (RETURN (LIST (QUOTE NLEFT)
EXPR N TAIL]
(ADVISE (QUOTE 'NOTLESSPLENGTH)
(QUOTE (RETURN <'NOT <'LESSP <'LENGTH X> N>>)))
[ADVISE (QUOTE 'NTH)
(QUOTE (RETURN (LIST (QUOTE NTH)
VAR LEN]
[ADVISE (QUOTE 'OR)
(QUOTE (RETURN (CONS (QUOTE OR)
LISTOFEXPRESSIONS]
[ADVISE (QUOTE 'PLUS)
(QUOTE (RETURN (LIST (QUOTE IPLUS)
EXPR1 EXPR2]
[ADVISE (QUOTE 'AND)
(QUOTE (RETURN (LIST (QUOTE AND)
EXPR1 EXPR2]
[ADVISE (QUOTE 'CAR)
(QUOTE (RETURN (LIST (QUOTE CAR)
X]
[ADVISE (QUOTE 'CDR)
(QUOTE (RETURN (LIST (QUOTE CDR)
X]
(ADVISE (QUOTE 'REPLACE)
(QUOTE (RETURN <'REPLACE VAR EXPR>)))
[ADVISE (QUOTE 'EQLENGTH)
(QUOTE (RETURN (LIST (QUOTE EQ)
(LIST (QUOTE LENGTH)
VAR)
LEN]
[ADVISE (QUOTE 'EQUAL)
(QUOTE (RETURN (LIST (QUOTE EQUAL)
VAR EXPRESSION]
[ADVISE (QUOTE 'NULL)
(QUOTE (RETURN (LIST (QUOTE NULL)
X]
(ADVISE (QUOTE 'EQ)
(QUOTE (RETURN (LIST (QUOTE EQ)
VAR EXPRESSION])
(SMART
[LAMBDA NIL
(EVAL (CONS (QUOTE UNADVISE)
(QUOTE ('NOT 'NLEFT 'NOTLESSPLENGTH 'NTH 'OR 'PLUS 'AND
'CAR 'CDR 'REPLACE 'EQLENGTH 'EQUAL 'NULL])
)
(RPAQQ FUNNYATOMLST
('MATCHTOP 'MATCH 'MATCHBIND 'MATCHELT 'MATCHEXP 'MATCHFIXED
'MATCHSUBPAT 'MATCHTAIL 'MATCHSOME 'MATCHWITHMEMB
'MATCHNNIL 'MATCHEXP1 LOCALPATVAR 'MATCH&SET
'CDRLEN POSTPONE 'HEADP 'NLEFT 'NOT 'NOTLESSPLENGTH
'NTH 'NTH{NUMBER⎇ 'OR 'PLUS 'REPLACE
'SETQ←SIDE←EFFECT 'REPLACE←SIDE←EFFECT 'SETQ
'SETVAR 'SOME 'AND '!AND 'CAR 'CDR 'EQ 'EQLENGTH
'EQUAL 'LENGTH 'LISTP 'NULL 'LAST 'TAILP 'LDIFF
'RETURN PATPARSE← MAKE!DEFAULT
POSTPONE←SIDE←EFFECTS PAT' PATELT' LAST-TYPE))
(RPAQQ VARTOMATCH var)
(RPAQ CURRENTFILE)
(RPAQ HOST)
(RPAQQ EXAMPLEFILE EXAMPLES)
(RPAQQ CLMATCHFLG NIL)
(RPAQQ PATTERNS (*ANY* '& &@NUMBERP &@STRINGP '$ '-- NIL T
('$PACKED$ ! (*ANY* &@NUMBERP
&@NUMBEREXPRESSION))
('@ &@GETD ! &@PATTERNELT)
((*ANY* '*EVERY* '*ANY*)
! &@LISTOFPATTERNELTS)
((*ANY* '<- '←)
&@VAR ! &@PATTERNELT)
((*ANY* '→ '->)
&@EXPRESSION ! &@PATTERNELT)
('= ! &@EXPRESSION)
('== ! &@EXPRESSION)
('' ! &@SEXPRESSION)
('* ! &@ PATTERNELT)
('SUBPAT ! &@LISTOFPATTERNELTS)
('} ! &@PATTERNELT)))
(DEFLIST(QUOTE(
[DEFINE
(NIL (AFTER NIL
(AND CURRENTFILE
(MAPC !VALUE
(FUNCTION
(LAMBDA (X)
(/NCONC1
(/DREMOVE X (CAAR (FILEVARS
CURRENTFILE))
)
X]
[LOAD (NIL (BIND NIL ((CURRENTFILE]
[UNBREAK0 (NIL (AFTER NIL (SETQ LASTWORD FN]
))(QUOTE READVICE))
(READVISE DEFINE LOAD UNBREAK0)
(RELINK (QUOTE (UNBREAK)))
(MOVD (QUOTE LISPXPRINT)
(QUOTE LISPXPRINTDEF))
(DEFLIST(QUOTE(
[ORR
(L (PROG ((TEM 0))
(CONS (QUOTE SELECTQ)
(CONS (LIST (QUOTE RAND1)
(LENGTH L))
(NCONC [MAPCAR L (FUNCTION
(LAMBDA
(X)
(LIST (SETQ TEM
(ADD1 TEM))
X]
(QUOTE ((HELP]
[LISTOF
(L ([LAMBDA
(EXPR MIN MAX)
(LIST (QUOTE PROG)
(QUOTE (VAL))
(LIST (QUOTE RPTQ)
[COND [MIN (LIST (QUOTE IPLUS)
MIN
(LIST (QUOTE RAND1)
(LIST (QUOTE IDIFFERENCE)
(OR MAX 10)
MIN]
(T (LIST (QUOTE RAND1)
(OR MAX 10]
(LIST (QUOTE SETQ)
(QUOTE VAL)
(CONS (QUOTE CONS)
(CONS EXPR (QUOTE (VAL]
(CAR L)
(CADR L)
(CADDR L]
))(QUOTE MACRO))
(DEFLIST(QUOTE(
[PATELT (NIL (BEFORE NIL (RETURN (TMPPATELT]
))(QUOTE READVICE))
STOP